Fifty: Elektronik/FIFTY Elektronik (PS_Computer_Vertrieb).iso/ps8/fty1017/gepackt.exe/DISK2/PLOTSRC.EXE/WINDOWS.IMP

Text File | 1993-11-10 | 16.5 KB | 514 lines

Type TypeBildschirm = ARRAY [1..2000] OF TypeSchirmbyte;

VAR  MonoSchirm   : TypeBildschirm ABSOLUTE $B000:0000; { Textmode }
     ColorSchirm  : TypeBildschirm ABSOLUTE $B800:0000; { Textmode }

Const ColorStackPtr:Word=0;

Var ColorStack :Array[0..15] of Record
                                  Tattr,
                                  Efore,
                                  Eback :Byte;
                                 end;
Const WindowStackPtr:Word=0;

Var WindowStack :Array[0..15] of Record
                                   Min,
                                   Max  :Word;
                                   X,Y  :Integer;
                                 end;

Function CalcAttr(fore,back:Byte):Byte;
Var blink:Byte;
begin
  Blink:=(fore and 16) shl 3;
  fore:=fore and 15;
  back:=(back and 7) shl 4;
  Calcattr:=fore or back or blink;
end;

FUNCTION VideoMode:BYTE;     { Welcher Monitor ist aktiv ? }

VAR Regs : Registers;

BEGIN
     WITH Regs DO BEGIN
          ah := 15;          { Get Current Video State }
          Intr ($10,Regs);   { Videointerrupt }
          VideoMode := al;   { ah   Videomodus  }
                             { 0    40*25 BW }
                             { 1    40*25 Color }
                             { 2    80*25 BW }
                             { 3    80*25 Color }
                             { 7    80*25 Monochrom Card }
       END;
END; { VideoMode }

Procedure IsColorMonitor;
Var mode:Byte;
BEGIN
  Mode:=Videomode;
  IsColor:= ((MEM[0064:0016] and 48 )<>48) OR (Mode IN [2,3]);
  ModeCO80:=(mode=3) and Iscolor;
END { IsColorMonitor } ;


PROCEDURE MakeWindow (VAR Slide                 : WindowType;  { Window erstellen }
                          Xo,Yo,Breite,Hoehe,At : BYTE;
                      VAR Ok                    : INTEGER);
VAR I : INTEGER;
BEGIN
     WITH Slide DO BEGIN
          Size := succ(Breite)*succ(Hoehe)*2;  { genügend Speicher holen }
          IF MemAvail <= Size THEN BEGIN    { Genügend Speicher vorhanden ? }
             Ok := $FF;                        { leider Nein, also raus }
             EXIT;
            END ELSE Ok := 0;
          GetMem (Inhalt,Size);                { Speicher holen }
          Save := NIL;                         { noch kein Hintergrund }
          Saved := FALSE;                      { gespeichert }
          X1 := Xo;                            { obere Linke Ecke }
          Y1 := Yo;                            { beim Anzeigen des Windows }
          Width := Breite;                     { Breite in Zeichen }
          Height := Hoehe;                     { Höhe in Zeichen }
          fillchar (Inhalt^,Size,$20);         { mit Spaces füllen }
          FOR I := 0 TO Pred(Size DIV 2) DO Inhalt^[I].At := At; { Attribut setzen }
      END;
END; { MakeWindow }

PROCEDURE GetWindow (VAR Slide              : WindowType; { Window vom }
                         Xo,Yo,Breite,Hoehe : BYTE;       { Bildschirm lesen  }
                     VAR Ok                 : INTEGER);
VAR I,W,sW,Xy : INTEGER;
BEGIN
     MakeWindow (Slide,Xo,Yo,Breite,Hoehe,32,Ok);         { Window erstellen }
     IF Ok<>0 THEN EXIT;                                  { Exit bei Speicherfehler }
     WITH Slide DO BEGIN
          W := Width*2;
          sW := succ(Width);
          Xy := Xo+80*pred(Yo);
          If IsColor THEN
             FOR I := 0 TO pred(Height) DO
                 Move  (ColorSchirm[Xy+80*I],Inhalt^[I*sW].W,W)
               ELSE
                   FOR I := 0 TO pred(Height) DO
                       Move (MonoSchirm[Xy+80*I],Inhalt^[I*sW].W,W)
      END;
END; { GetWindow }

PROCEDURE PutWindow (VAR Slide : Windowtype;  { Window anzeigen und Hintergrund }
                     VAR Ok    : INTEGER);    { sichern }
VAR I,W,Xy,sW : INTEGER;
BEGIN
     WITH Slide DO BEGIN
         IF MemAvail <= Size THEN BEGIN
             Ok := $FF;
             EXIT;
            END ELSE Ok := 0;
          GetMem (Save,Size);                 { Speicher für Hintergrund }
          W := Width*2;
          sW := succ(Width);
          Xy := X1+80*pred(Y1);
          If IsColor THEN
             FOR I := 0 TO pred(Height) DO BEGIN
                 Move(ColorSchirm[Xy+80*I],Save^[I*sW].W,W);
                 Move (Inhalt^[I*sW].W,ColorSchirm[Xy+80*I],W);
                END
               ELSE
                   FOR I := 0 TO pred(Height) DO BEGIN
                       Move(MonoSchirm[Xy+80*I],Save^[I*sW].W,W);
                       Move(Inhalt^[I*sW].W,MonoSchirm[Xy+80*I],W);
                END;
          Saved := TRUE;
        END; { WITH Slide DO }
END; { PutWindow }

PROCEDURE ShowWindow (VAR Slide : Windowtype); { Anzeigen ohne sichern des }
VAR I,Xy,W,sW : INTEGER;                       { Hintergrundes }
BEGIN
     WITH Slide DO BEGIN
          W := Width*2;
          sW := succ(Width);
          Xy := X1+80*pred(Y1);
          If IsColor THEN
             FOR I := 0 TO pred(Height) DO
                 Move (Inhalt^[I*sW].W,ColorSchirm[Xy+80*I],W)
               ELSE
                   FOR I := 0 TO pred(Height) DO
                       Move (Inhalt^[I*sW].W,MonoSchirm[Xy+80*I],W)
     END;
END; { ShowWindow }


PROCEDURE RestoreWindow ( VAR Slide : WindowType; { Hintergrund restaurieren }
                          VAR Ok    : INTEGER);
VAR I,Xy,W,sW : INTEGER;
BEGIN
     WITH Slide DO IF Saved THEN BEGIN
          W := Width*2;
          sW := succ(Width);
          Xy := X1+80*pred(Y1);
          If IsColor THEN
             FOR I := 0 TO pred(Height) DO
                 Move (Save^[I*sW].W,ColorSchirm[Xy+80*I],W)
               ELSE
                   FOR I := 0 TO pred(Height) DO
                       Move (Save^[I*sW].W,MonoSchirm[Xy+80*I],W);
          FreeMem (Save,Size);           { Speicher wieder freimachen }
          Saved := False;
          Ok := 0;
        END
       ELSE Ok := $FF; { not saved, no Restore ! }
END; { RestoreWindow }

PROCEDURE WriteToWindow (VAR Slide  : WindowType;  { Beschriftung von Windows }
                             X,Y,At : BYTE;
                             Zeile  : Str80);
VAR I : BYTE;
BEGIN
     WITH Slide DO BEGIN
          IF Inhalt=NIL THEN EXIT;                 { gibts das Window überhaupt ? }
          IF Y>(Height) THEN EXIT;                 { Zeilennummer zu groß ? }
          Zeile := copy (Zeile,1,Width);           { Zeilenlänge korrigieren }
          FOR I := 1 TO length(Zeile) DO
              Inhalt^[pred(Y)*succ(Width)+pred(X)+pred(I)].W :=
                     ord(Zeile[I]) + At SHL 8;
      END;
END; { WriteToWindow }

PROCEDURE MakeFrame (VAR Slide  : WindowType;      { Windows Einrahmen }
                         At,Typ : BYTE);

TYPE  Koordinaten = (lo,ro,lu,ru,s,w);
      FrameType = ARRAY [1..2,Koordinaten] OF CHAR;
CONST Frame : FrameType = (('┌','┐','└','┘','│','─'),  { Einfach und }
                           ('╔','╗','╚','╝','║','═')); { Doppelrahmen }
VAR I : BYTE;
BEGIN
     IF (Typ<1) OR (Typ>2) THEN Typ := 1;
     WITH Slide DO BEGIN
          IF Inhalt=NIL THEN EXIT;
          WriteToWindow (Slide,1,1,At,Frame[Typ,lo]);
          WriteToWindow (Slide,Width,1,At,Frame[Typ,ro]);
          WriteToWindow (Slide,1,Height,At,Frame[Typ,lu]);
          WriteToWindow (Slide,Width,Height,At,Frame[Typ,ru]);
          FOR I := 2 TO pred(Height) DO BEGIN
              WriteToWindow (Slide,1,I,At,Frame[Typ,s]);
              WriteToWindow (Slide,Width,I,At,Frame[Typ,s]);
             END;
          FOR I := 2 TO pred(Width) DO BEGIN
              WriteToWindow (Slide,I,1,At,Frame[Typ,w]);
              WriteToWindow (Slide,I,Height,At,Frame[Typ,w]);
             END;
      END;
END; { MakeFrame }

PROCEDURE MoveWindow ( VAR Slide  : WindowType;  { Window von der aktuellen }
                           X,Y    : BYTE;        { an neue Position bringen. }
                       VAR Ok     : INTEGER);    { und anzeigen }
BEGIN
     WITH Slide DO BEGIN
          IF Saved THEN BEGIN
             RestoreWindow (Slide,Ok);
             IF Ok<>0 THEN EXIT ELSE Ok := 0;
            END;
          X1 := X;
          Y1 := Y;
       END;
     PutWindow (Slide,Ok);
END; { MoveWindow }

PROCEDURE DeleteWindow ( VAR Slide : WindowType );  { Windowspeicher freigeben }
BEGIN
     WITH Slide DO BEGIN
          IF Saved AND (Save <> NIL) THEN BEGIN
             FreeMem (Save,Size);
             Saved := False;
             Save := NIL;
            END;
          IF Inhalt<>NIL THEN FreeMem (Inhalt,Size);
          Inhalt := NIL;
       END;
END; { DeleteWindow }

PROCEDURE MakeMenue (VAR Menu          : MenueType;  { MAC Menü erstellen }
                         Xo,Yo,Breite,               { Window mit Rahmen }
                         Hoehe,Punkte,               { und Angabe der }
                         Farbe,Balken,
                         KeyCol        : BYTE;       { Auswahlmöglichkeiten }
                         MenueText     : MenueTextPtr;
                     VAR Ok            : INTEGER);
VAR I,pt : BYTE;
    S :Str80;
BEGIN
     WITH Menu DO BEGIN
          MakeWindow (Picture,Xo,Yo,Breite,Hoehe,Farbe,Ok);
          IF Ok<>0 THEN EXIT ELSE Ok := 0;
          MakeFrame (Picture,Farbe,1);               { Einfacher Rand }
          Items := Punkte;
          Color:=Farbe;
          If (Color and $F0)=0 then
                  Color:=Color and $07;
          LastSel:=1;
          HiColor:=KeyCol;
          Fillchar(HotKeys,Sizeof(HotKeys),0);
          FOR I := 1 TO Items DO
            begin
              S:=Menuetext^[I];
              Pt:=Pos('~',S);
              With HotKeys[I] Do
              begin
                If (Pt>0) and (Pt<Length(S)) then
                begin
                  Delete(S,Pt,1);
                  Key:=S[Pt];
                  P:=Pt;
                  Pt:=Pos('~',S);
                  If (Pt>0) then
                     Delete(S,Pt,1);
                end;
                S:=copy(S,1,Breite-2);
                WriteToWindow (Picture,2,1+I,Color,S);
                If Key<>#0 then
                  WriteToWindow(Picture,1+P,1+I,KeyCol,Key);
              end;
          end;
          Pcolor := Balken;
       END;
END; { MakeMenue }

PROCEDURE FlipLine (X,Y,At,Len : INTEGER); { Zeile auf Bildschirm umfärben }
VAR I : INTEGER;                           { für den Aufbau von 'Scrollbars' }
    P : INTEGER;
BEGIN
     Y := pred (Y) * 80;
     IF IsColor THEN FOR I := X TO pred(X+Len) DO BEGIN
         P := Y+I;
         ColorSchirm[P].At:=At;
       END
      ELSE FOR I := X TO pred(X+Len) DO BEGIN
               P := Y+I;
               MonoSchirm[P].At := At;  { Hier ist alles simpel }
             END;
END; { FlipLine }



FUNCTION GetKey(Term:Charset):Char;    { Eine Taste lesen }
   VAR Ch : CHAR;
       Dummy:Integer;
   BEGIN
        REPEAT
          Dummy:=ReadKbd(Ch);      { lesen }
          Ch:=Upcase(Ch);
        UNTIL Ch IN Term;
        GetKey := Ch;
   END; { GetKey }

FUNCTION GetMenueChoice ( VAR Menu : MenueType;         { Menü anzeigen und }
                          VAR Ok   : INTEGER   ):BYTE;  { Auswahl lesen }
VAR X,Y,W : BYTE;
    Yl,Yh : BYTE;
    Key   : Char;
    OkSet :Charset;
    NewSel,
    I     : Integer;

   Function IsHotKey(C:Char):Byte;
   Var I:Integer;
   begin
     IsHotKey:=0;
     For I:=1 to Menu.Items do
      begin
        If Upcase(C)=Upcase(Menu.HotKeys[I].Key) then
          begin
            IsHotKey:=I;
            Exit;
          end;
      end;
   end;


BEGIN { GetMenueChoice }
     ResetMouseDelta;
     FlushKbd;
     WITH Menu DO BEGIN
          PutWindow (Picture,Ok);                { Menü anzeigen }
          IF Ok<>0 THEN EXIT ELSE Ok := 0;
          Okset:=[^M,Esc,^E,^X,^Q];
          For  I:=1 to Items do
            With HotKeys[I] do
             If Key<>#0 then
              begin
                Okset:=Okset+[Upcase(Key)];
              end;
          Yh := succ(Picture.Y1);                { Bewegungsbereich festlegen }
          If LastSel<1 then LastSel:=1;
          If LastSel>Items then LastSel:=1;
          Y := Yh+LastSel-1;
          Yl := Yh+Items-1;
          X := succ(Picture.X1);
          W := Picture.Width-2;
          FlipLine (X,Y,Pcolor,W);               { Erste Zeile anzeigen }
          With HotKeys[Y-Picture.Y1] do
            If Key<>#0 then
                FlipLine(X+P-1,Y,(HiColor and $F) or (PColor and $F0),1);
          REPEAT
            Key := GetKey(OkSet);{ auf Taste warten }
            FlipLine (X,Y,Color,W);          { Zeile restaurieren }
            With HotKeys[Y-Picture.Y1] do
              If Key<>#0 then
                FlipLine(X+P-1,Y,HiColor,1);
            CASE Key OF
            ^E : BEGIN { Up }
                      Y := pred (Y);
                      IF Y<Yh THEN Y := Yl;
                  END;
            ^X : BEGIN { Down }
                      Y := succ (Y);
                      IF Y>Yl THEN Y := Yh;
                  END;
              END; { CASE }
            FlipLine (X,Y,Pcolor,W);         { neue Zeile zeigen }
            With HotKeys[Y-Picture.Y1] do
              If Key<>#0 then
                FlipLine(X+P-1,Y,(HiColor and $F) or (PColor and $F0),1);
          UNTIL (Key IN [^M,Esc,^Q]) or (IsHotKey(Key)>0);
          Case Key of
           ^M,^Q: NewSel:= Y-Picture.Y1;
           Esc  : NewSel:= 0;   { oder ESC gedrückt }
           ELSE NewSel:=IsHotKey(Key);
          end;
          If NewSel<>0 then LastSel:=NewSel;
          GetMenueChoice:=NewSel;
          RestoreWindow (Picture,Ok);                   { Hintergrund anzeigen }
      END;
END; { GetMenueChoice }

PROCEDURE DisplayString (X,Y,At:BYTE; S:Str80); { Direkt auf den Bildschirm }
VAR I,L     : INTEGER;                          { schreiben }
    ScrLine : ARRAY [1..80] OF TypeSchirmByte;


BEGIN
     L:=Length(S);
     IF L>0 THEN BEGIN
        fillchar (ScrLine,sizeof(ScrLine),At);
        FOR I := 1 TO L DO ScrLine[I].Ch := S[I];
        IF IsColor THEN Move (ScrLine,ColorSchirm[X+80*pred(Y)],2*L)
         ELSE Move (ScrLine,MonoSchirm[X+80*pred(Y)],2*L);
       END;
END; { DisplayString }


PROCEDURE DisplayInteger (X,Y,At:BYTE; Z:INTEGER; L:BYTE; Left:BOOLEAN);
VAR S : STRING [10];     { Feldlänge L, Linksbündig mit Left }
BEGIN
  Str(Z:L,S);
  IF LEFT THEN WHILE S[1]=' ' DO S := copy(S,2,length(S));
     DisplayString (X,Y,At,S);
END; { DisplayInteger }

PROCEDURE DisplayReal (X,Y,At:BYTE; Z:REAL; L,K:INTEGER; Left:BOOLEAN);
VAR S : STRING [30];     { Feldlänge L, Nachkomma K , Linksbündig mit Left }
BEGIN
     str (Z:L:K,S);
     IF LEFT THEN WHILE S[1]=' ' DO S := copy(S,2,length(S));
     DisplayString (X,Y,At,S);
END; { DisplayReal }

Procedure FullScreen;
begin
  Window(1,1,80,25);
end;

Procedure SetEditColors(Tfore,tback,Efore,Eback:Byte);
 Function Nbits(C:Byte):Integer;
   Var N:Integer;
 begin
   N:=0;
   While C<>0 do
     begin
       C:=C shr 1;
       Inc(N,1);
     end;
   Nbits:=N;
 end;
begin
  If ModeCO80 then
    begin
      Editforeground:=Efore;
      Editbackground:=Eback;
      TextColor(Tfore);
      TextbackGround(Tback);
    end
  else
     begin
      If Nbits(Tfore)>Nbits(tback) then
        begin
          TextColor(Crt.lightgray);
          TextbackGround(Crt.black);
        end
      else
       begin
        TextColor(Crt.black);
        TextbackGround(Crt.lightgray);
       end;
      If Nbits(Efore)>Nbits(Eback) then
      begin
        Editforeground:=Crt.White;
        Editbackground:=Crt.black;
      end
      else
        begin
          Editforeground:=Crt.Black;
          Editbackground:=Crt.lightgray;
        end;
    end;
end;

Procedure SaveColors;
begin
  With ColorStack[ColorStackPtr] do
   begin
     Tattr:=TextAttr;
     Efore:=EditForeGround;
     Eback:=EditBackGround;
   end;
  Inc(ColorStackPtr,1);
end;

Procedure RestoreColors;
begin
  Dec(ColorStackPtr,1);
  With ColorStack[ColorStackPtr] do
   begin
     TextAttr:=Tattr;
     EditForeGround:=Efore;
     EditBackGround:=Eback;
   end;
end;

Procedure SaveCrtWindow;
begin
  With WindowStack[WindowStackPtr] do
   begin
     X:=Crt.WhereX;
     Y:=Crt.WhereY;
     Min:=Crt.WindMin;
     Max:=Crt.WindMax;
   end;
  Inc(WindowStackPtr,1);
end;

Procedure RestoreCrtWindow;
begin
  Dec(WindowStackPtr,1);
  With WindowStack[WindowStackPtr] do
   begin
     Crt.WindMin:=Min;
     Crt.WindMax:=Max;
     GotoXY(X,Y);
   end;
end;